home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Scrollcanvas.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  3.6 KB  |  99 lines
  1. ;;;;
  2. ;;;; S c r o l l c a n v a s . s t k       --  Scroll Canvas composite widget
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  15. ;;;;    Creation date: 25-Mar-1995 11:03
  16. ;;;; Last file update:  2-Jul-1996 12:09
  17.  
  18. (require "Tk-classes")
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;;;
  22. ;;;; <Scroll-canvas> class definition
  23. ;;;;
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25.  
  26. (define-class <Scroll-canvas> (<Tk-composite-widget> <Canvas>)
  27.   ((canvas       :accessor     canvas-of)
  28.    (h-scrollbar      :accessor     h-scrollbar-of)
  29.    (v-scrollbar      :accessor     v-scrollbar-of)
  30.    (h-scroll-side :accessor     h-scroll-side
  31.           :allocation   :virtual
  32.           :init-keyword :h-scroll-side
  33.           :slot-ref     (lambda (o)
  34.                   (let ((hs (slot-ref o 'h-scrollbar)))
  35.                     (and (winfo 'ismapped hs)
  36.                      (get-keyword :side (pack 'info hs)))))
  37.           :slot-set!    (lambda (o v) 
  38.                   (let ((hs (slot-ref o 'h-scrollbar)))
  39.                     (if v
  40.                     (pack hs :fill "x" :side v 
  41.                              :before (slot-ref o 'canvas))
  42.                     (pack 'forget hs)))))
  43.  
  44.    (v-scroll-side :accessor     v-scroll-side
  45.           :allocation   :virtual
  46.           :init-keyword :v-scroll-side
  47.           :slot-ref     (lambda (o)
  48.                   (let ((vs (slot-ref o 'v-scrollbar)))
  49.                     (and (winfo 'ismapped vs)
  50.                      (get-keyword :side (pack 'info vs)))))
  51.           :slot-set!    (lambda (o v)
  52.                   (let ((vs (slot-ref o 'v-scrollbar)))
  53.                     (if v 
  54.                     (pack vs :fill "y" :side v 
  55.                           :before (slot-ref o 'canvas))
  56.                     (pack 'forget vs)))))
  57.    ;; Non allocated slots
  58.    (background   :accessor     background
  59.          :init-keyword :background
  60.          :allocation   :propagated
  61.          :propagate-to (frame canvas h-scrollbar v-scrollbar))
  62.    (border-width :accessor     border-width 
  63.          :allocation   :propagated
  64.          :init-keyword :border-width
  65.          :propagate-to (frame))
  66.    (relief     :accessor     relief
  67.          :init-keyword :relief
  68.          :allocation   :propagated
  69.          :propagate-to (frame))))
  70.  
  71. ;;;;
  72. ;;;;  <Scroll-canvas> methods
  73. ;;;;
  74.  
  75. (define-method initialize-composite-widget ((self <Scroll-canvas>) initargs parent)
  76.   (let* ((hs (make <Scrollbar> :parent parent :orientation "horizontal"))
  77.      (vs (make <Scrollbar> :parent parent :orientation "vertical"))
  78.      (c  (make <Canvas>    :parent parent)))
  79.     ;; Set internal true slots 
  80.     (slot-set! self 'Id              (slot-ref c 'Id))
  81.     (slot-set! self 'canvas       c)
  82.     (slot-set! self 'h-scrollbar  hs)
  83.     (slot-set! self 'v-scrollbar  vs)
  84.  
  85.     ;; Pack internal widgets (Warning: Order is dependant !!!!)
  86.     (pack vs :fill 'y :side 'right)
  87.     (pack c  :expand #t :fill "both" :side 'bottom :after vs)
  88.     (pack hs :fill 'x :after c)
  89.  
  90.     ;; Attach command to scrollbar and canvas
  91.     (slot-set! c 'x-scroll-command (lambda l (apply (slot-ref hs 'Id) 'set l)))
  92.     (slot-set! c 'y-scroll-command (lambda l (apply (slot-ref vs 'Id) 'set l)))
  93.  
  94.     (slot-set! hs 'command (lambda args (apply (slot-ref c 'Id) 'xview args)))
  95.     (slot-set! vs 'command (lambda args (apply (slot-ref c 'Id) 'yview args)))
  96. ))
  97.  
  98. (provide "Scrollcanvas")
  99.